home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / expand2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  44.0 KB  |  1,466 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #define GEN
  10.  
  11. #include "hdr.h"
  12. #include "libhdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "gmainprots.h"
  17. #include "setprots.h"
  18. #include "miscprots.h"
  19. #include "gnodesprots.h"
  20. #include "gutilprots.h"
  21. #include "gmiscprots.h"
  22. #include "initobjprots.h"
  23. #include "arithprots.h"
  24. #include "chapprots.h"
  25. #include "smiscprots.h"
  26. #include "expandprots.h"
  27.  
  28. static Tuple constrained_type(Symbol, Node, Node);
  29. static int array_nelem(Node);
  30. static void replace_name(Node, Symbol, Symbol);
  31.  
  32. static int array_nelem_defined; /* set if array_nelem undefined */
  33.  
  34. void expand_line()                                            /*;expand_line*/
  35. {
  36.     /* called when expander reaches line debug_line if debug_line is not
  37.      * zero. This is meant to provide useful trapping point for
  38.      * interactive debugging.        ds 7-19-85
  39.      */
  40. }
  41.  
  42.  
  43. int in_bin_ops(Symbol op)                                    /*;in_bin_ops*/
  44. {
  45.     /*     bin_ops = {'and',  'or',  'xor', '&', '&ac', '&ca', &cc'
  46.      *     '=',    '/=',  '<=',  '>',    '>=',   '<',     
  47.      *     '+i',   '-i',   '*i',  '/i',  '**i',  'remi', 'modi', 
  48.      *     '+fl',   '-fl',  '*fl', '/fl', '**fl', 
  49.      *     '+fx',   '-fx',  '*fx', '/fx', '*fix', '*fxi', '/fxi'},
  50.      */
  51.     return op == symbol_and || op == symbol_or || op == symbol_xor 
  52.       || op == symbol_cat || op == symbol_cat_cc || op == symbol_cat_ca
  53.       || op == symbol_cat_ac || op == symbol_eq || op == symbol_ne
  54.       || op == symbol_le || op == symbol_gt || op == symbol_ge
  55.       || op == symbol_lt || op == symbol_addi || op == symbol_subi
  56.       || op == symbol_muli || op == symbol_divi || op == symbol_expi 
  57.       || op == symbol_remi || op == symbol_modi || op == symbol_addfl
  58.       ||op == symbol_subfl || op == symbol_mulfl || op == symbol_divfl
  59.       || op == symbol_expfl || op == symbol_addfx || op == symbol_subfx
  60.       || op == symbol_mulfx || op == symbol_divfx || op == symbol_mulfix
  61.       || op == symbol_mulfxi || op == symbol_divfxi;
  62. }
  63.  
  64. int in_un_ops(Symbol op)                                    /*;in_un_ops*/
  65. {
  66.     /*    un_ops =  {'not', '-ui',  '+ui',  'absi', '-ufl', '+ufl', 'absfl',
  67.      *    '-ufx', '+ufx', 'absfx'  };
  68.      */
  69.  
  70.     return op == symbol_not || op == symbol_subui || op == symbol_addui
  71.       || op == symbol_absi || op == symbol_subufl || op == symbol_addufl
  72.       || op == symbol_absfl || op == symbol_subufx || op == symbol_addufx
  73.       || op == symbol_absfx;
  74. }
  75.  
  76. void expand_block(Node decl_node, Node stmt_node, Node exc_node, Node term_node)
  77.                                                             /*;expand_block*/
  78. {
  79.     Node    stmt_list_node;
  80.  
  81.     if (decl_node != OPT_NODE)
  82.         expand(decl_node);
  83.  
  84.     stmt_list_node = N_AST1(stmt_node);
  85.     N_LIST(stmt_list_node) = tup_with(N_LIST(stmt_list_node),
  86.       (char *) copy_tree(term_node));
  87.     expand(stmt_node);
  88.  
  89.     if (exc_node != OPT_NODE) {
  90.         /* Note: exc node may be a sequence of statements */
  91.         if (N_KIND(exc_node) == as_exception) {
  92.             N_AST1(exc_node) = term_node;
  93.             if (N_AST2_DEFINED(as_exception)) N_AST2(exc_node) = (Node) 0;
  94.             if (N_AST3_DEFINED(as_exception)) N_AST3(exc_node) = (Node) 0;
  95.             if (N_AST4_DEFINED(as_exception)) N_AST4(exc_node) = (Node) 0;
  96.         }
  97.         expand(exc_node);
  98.     }
  99. }
  100.  
  101. static Tuple constrained_type(Symbol array_type, Node lbd_node, Node ubd_node)
  102.                                                         /*;constrained_type*/
  103. {
  104.     /*
  105.      * Given an unconstrained array type, constructs a constrained subtype
  106.      * with the given bounds.
  107.      * returns [type_name, decls] where type_name is the name of the
  108.      * constrained array subtype, and decls a list (tuple) of nodes necessary
  109.      * to elaborate the type.
  110.      */
  111.  
  112.     Symbol   bt, index_name, array_name, comp_type;
  113.     Node    range_node, indic_node, ix_name_node, index_node, ar_name_node,
  114.       array_node;
  115.     Tuple    tup, dtup;
  116.  
  117.     bt = base_type(N_TYPE(lbd_node));
  118.  
  119.     /* 1- Create range node */
  120.     range_node        = node_new(as_range);
  121.     N_AST1(range_node) = lbd_node;
  122.     N_AST2(range_node) = ubd_node;
  123.     indic_node        = node_new(as_subtype_indic);
  124.     N_AST1(indic_node) = new_name_node(bt);
  125.     N_AST2(indic_node) = range_node;
  126.  
  127.     /* 2- Create index subtype */
  128.     index_name         = new_unique_name("index");
  129.     ix_name_node       = new_name_node(index_name);
  130.     index_node         = node_new(as_subtype_decl);
  131.     N_AST1(index_node) = ix_name_node;
  132.     N_AST2(index_node) = indic_node;
  133.     tup = constraint_new(co_range);
  134.     tup[2] = (char *) lbd_node;
  135.     tup[3] = (char *) ubd_node;
  136.     new_symbol(index_name, na_subtype, bt, tup, ALIAS(bt));
  137.     CONTAINS_TASK(index_name) = FALSE;
  138.  
  139.     /* 3- Create constrained array subtype */
  140.     indic_node         = node_new(as_constraint);
  141.     N_LIST(indic_node) = tup_new1( (char *) new_name_node(index_name));
  142.     array_name         = new_unique_name("array");
  143.     ar_name_node       = new_name_node(array_name);
  144.     array_node         = node_new(as_subtype_decl);
  145.     N_AST1(array_node)  = ar_name_node;
  146.     N_AST2(array_node)  = indic_node;
  147.     comp_type = (Symbol) (SIGNATURE(array_type))[2];
  148.     tup = tup_new(2);
  149.     tup[1] = (char *) tup_new1( (char *) index_name);
  150.     tup[2] = (char *) comp_type;
  151.     new_symbol(array_name, na_subtype, array_type,
  152.       tup, ALIAS(array_type));
  153.     CONTAINS_TASK(array_name) = CONTAINS_TASK(array_type);
  154.     dtup = tup_new(2);
  155.     dtup[1] = (char *) index_node;
  156.     dtup[2] = (char *) array_node;
  157.     tup = tup_new(2);
  158.     tup[1] = (char *) array_name;
  159.     tup[2] = (char *) dtup;
  160.     return tup;
  161. }
  162.  
  163. static int array_nelem(Node node)                            /*;array_nelem*/
  164. {
  165.     /*
  166.      * Given a node that is appropriate for an array type, determines the
  167.      * number of elements if known statically, returns OM otherwise.
  168.      */
  169.  
  170.     Symbol   node_name, type_name, index_sym;
  171.     Tuple     index_list, tup;
  172.     int        size, nk;
  173.     Node        nod2, lbd_node, ubd_node;
  174.     Fortup    ft1;
  175.     Const    lbd, ubd;
  176.  
  177.     /* the global (to this module) variable array_nelem_defined is set to
  178.      * FALSE if the SETL version of this procedure returns OM, TRUE otherwise
  179.      */
  180.     array_nelem_defined = TRUE; /* assume defined */
  181.     nk = N_KIND(node);
  182.     if (nk == as_subtype_indic) {
  183.         nk = (int) N_KIND((N_AST2(node) == OPT_NODE) ?
  184.           N_AST1(node) : N_AST2(node));
  185.         nod2 = N_AST2(node);
  186.     }
  187.     if (nk == as_string_ivalue) {
  188.         return tup_size((Tuple) N_VAL(node));
  189.     }
  190.     else if (nk == as_simple_name) {
  191.         node_name = N_UNQ(node);
  192.         if (NATURE(node_name) == na_type) {
  193.             array_nelem_defined = FALSE;
  194.             return 0;    /* always unconstrained */
  195.         }
  196.         else if ( NATURE(node_name) == na_subtype) {
  197.             type_name = node_name;
  198.         }
  199.         else { /* object */
  200.             type_name = N_TYPE(node);
  201.         }
  202.         tup        = SIGNATURE(type_name);
  203.         index_list = (Tuple) tup[1];
  204.         size       = 1;
  205.         FORTUP(index_sym  = (Symbol), index_list, ft1);
  206.             tup = SIGNATURE(index_sym);
  207.             lbd_node = (Node) tup[2];
  208.             ubd_node = (Node) tup[3];
  209.             lbd = get_ivalue(lbd_node);
  210.             ubd = get_ivalue(ubd_node);
  211.             if (lbd->const_kind != CONST_OM  && ubd->const_kind != CONST_OM) {
  212.                 if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
  213.                     return 0;
  214.                 else
  215.                     size *= get_ivalue_int(ubd_node)-get_ivalue_int(lbd_node)+1;
  216.             }
  217.             else{
  218.                 array_nelem_defined = FALSE;
  219.                 return 0;
  220.             }
  221.         ENDFORTUP(ft1);
  222.         return size;
  223.     }
  224. #ifdef TBSL
  225.     /* Wrong because the type_name is the base_type*/
  226.     else if (nk == as_array_aggregate || nk == as_array_ivalue)  {
  227.         type_name  = N_TYPE(node);
  228.         tup        = SIGNATURE(type_name);
  229.         index_list = (Tuple) tup[1];
  230.         size       = 1;
  231.         FORTUP(index_sym  = (Symbol), index_list, ft1);
  232.         tup = SIGNATURE(index_sym);
  233.         lbd_node = (Node) tup[2];
  234.         ubd_node = (Node) tup[3];
  235.         lbd = get_ivalue(lbd_node);
  236.         ubd = get_ivalue(ubd_node);
  237.         if (lbd->const_kind != CONST_OM  &&
  238.             ubd->const_kind != CONST_OM) {
  239.             if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node)) {
  240.                 return 0;
  241.             }
  242.             else {
  243.                 size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
  244.             }
  245.         }
  246.         else{
  247.             array_nelem_defined = FALSE;
  248.             return 0;
  249.         }
  250.         ENDFORTUP(ft1);
  251.         return size;
  252.     }
  253. #endif
  254.     else if (nk == as_range) {
  255.         lbd_node = N_AST1(nod2);
  256.         ubd_node = N_AST2(nod2);
  257.         size     = 1;
  258.         lbd = get_ivalue(lbd_node);
  259.         ubd = get_ivalue(ubd_node);
  260.         if (lbd->const_kind != CONST_OM  && ubd->const_kind != CONST_OM) {
  261.             if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
  262.                 return 0;
  263.             else
  264.                 size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
  265.         }
  266.         else{
  267.             array_nelem_defined = FALSE;
  268.             return 0;
  269.         }
  270.         return size;
  271.     }
  272.     else {
  273.         /*compiler_error_k("Array_nelem: kind = ", node);*/
  274.         /*TBSL : does not make the test for a slice, 
  275.          *a convert, a call, an op.              
  276.          */
  277.         array_nelem_defined = FALSE;
  278.         return 0;
  279.     }
  280. }
  281.  
  282. Symbol op_kind(Node node)                                        /*;op_kind*/
  283. {
  284.     /* Given a as_op node, returns the unique name of the operator */
  285.  
  286.     Node    id_node;
  287.  
  288.     id_node = N_AST1(node);
  289.     return N_UNQ(id_node);
  290. }
  291.  
  292. static void replace_name(Node node, Symbol old_name, Symbol new_name)
  293.                                                             /*;replace_name*/
  294. {
  295.     /* Replaces all occurences of old_name by new_name in the tree rooted at
  296.      * node.
  297.      */
  298.  
  299.     Node    subnode;
  300.     Fortup    ft1;
  301.     int    nk;
  302.  
  303.     if (node == (Node)0)
  304.         chaos("replace_name called on null node");
  305.     if (N_UNQ(node) == old_name )
  306.         N_UNQ(node) = new_name;
  307.  
  308.     nk = N_KIND(node);
  309.     if (N_AST1_DEFINED(nk) && N_AST1(node) != (Node)0)
  310.         replace_name(N_AST1(node), old_name, new_name);
  311.     if (N_AST2_DEFINED(nk) && N_AST2(node) != (Node)0)
  312.         replace_name(N_AST2(node), old_name, new_name);
  313.     if (N_AST3_DEFINED(nk) && N_AST3(node) != (Node)0)
  314.         replace_name(N_AST3(node), old_name, new_name);
  315.     if (N_AST4_DEFINED(nk) && N_AST4(node) != (Node)0)
  316.         replace_name(N_AST4(node), old_name, new_name);
  317.     if (N_LIST_DEFINED(nk) && N_LIST(node) != (Tuple)0) {
  318.         FORTUP(subnode = (Node), N_LIST(node), ft1);
  319.             replace_name(subnode, old_name, new_name);
  320.         ENDFORTUP(ft1);
  321.     }
  322. }
  323.  
  324. void mint(Node node)                                            /*;mint*/
  325. {
  326.     /* Deletes all occurences of :
  327.      *     as_qualify, as_name, as_conditon, as_parenthesis
  328.      * in the tree rooted at node.
  329.      */
  330.  
  331.     register int    i, nk;
  332.     Tuple    tup;
  333.  
  334.     nk= N_KIND(node);
  335.     if (N_AST1_DEFINED(nk)  && N_AST1(node) != (Node)0) mint(N_AST1(node));
  336.     if (N_AST2_DEFINED(nk)  && N_AST2(node) != (Node)0) mint(N_AST2(node));
  337.     if (N_AST3_DEFINED(nk)  && N_AST3(node) != (Node)0) mint(N_AST3(node));
  338.     if (N_AST4_DEFINED(nk)  && N_AST4(node) != (Node)0) mint(N_AST4(node));
  339.     if (N_LIST_DEFINED(nk) && N_LIST(node) != (Tuple)0) {
  340.         tup = N_LIST(node);
  341.         for (i = (int)*tup++; i > 0; i--)
  342.             mint((Node)*tup++);
  343.     }
  344.  
  345.     if (nk == as_name || nk == as_parenthesis || nk == as_condition)
  346.         copy_attributes(N_AST1(node), node);
  347.     else if (nk == as_qualify)
  348.         copy_attributes(N_AST2(node), node);
  349. }
  350.  
  351. void check_priv_instance(Tuple must_constrain, Symbolmap instance_map)
  352.                                                         /*;check_priv_instance*/
  353. {
  354.     /*
  355.      * For a late instantiation, verify that a private generic type that is
  356.      * used to declare an object has been instantiated with a constrained
  357.      * type.
  358.      */
  359.  
  360.     Fortup    ft1;
  361.     Symbol    g_name, new_type;
  362.  
  363.     FORTUP(g_name = (Symbol), must_constrain, ft1);
  364.         if (tup_mem((char *)g_name, must_constrain) ) {
  365.             new_type = symbolmap_get(instance_map, g_name);
  366.             if ( NATURE(new_type) == na_array
  367.               || (NATURE(new_type) == na_record && has_discriminants(new_type)
  368.               && (Node) default_expr((Symbol)discriminant_list(new_type)[2])
  369.               /* this is 1st discrim, as 'constrained' is added by expander */
  370.               == OPT_NODE )) {
  371.                 user_error(
  372.  "usage of generic private type requires instantiation with constrained type");
  373.             }
  374.         }
  375.     ENDFORTUP(ft1);
  376. }
  377.  
  378. void expand_decl(Node node)                                    /*;expand_decl*/
  379. {
  380.     Fortup  ft1;
  381.     Node    id_list_node, type_indic_node, init_node, first_obj_node,
  382.       const_val_node, decl_node, id_node, constrained_node;
  383.     Symbol  init_type_name, first_obj_name, type_name, p;
  384.     Tuple   tup;
  385.     int     is_var_decl, init_len, init_len_defined,
  386.     const_len, const_len_defined, is_agg;
  387.  
  388.     /*       Note: const decl are always single declarations (split by FE).
  389.      *       otherwise, the case of deferred constants would be more
  390.      *       difficult.
  391.      */
  392.     id_list_node = N_AST1(node);
  393.     type_indic_node = N_AST2(node);
  394.     init_node = N_AST3(node);
  395.     init_type_name = N_TYPE(init_node);
  396.     is_var_decl    = N_KIND(node) == as_obj_decl;
  397.     first_obj_node = (Node) ((Tuple) N_LIST(id_list_node))[1];
  398.     first_obj_name = N_UNQ(first_obj_node);
  399.     type_name      = TYPE_OF(first_obj_name);
  400.  
  401.     if (!is_var_decl && init_node == OPT_NODE) {
  402.         /*
  403.          *      Deferred constant: transform into variable, as it has no
  404.          *      initialization and cannot be unconstrained (LRM 7.4.1(3))
  405.          *      Defer elaboration of this "variable" after elaboration of the
  406.          *      type, but before elaboration of any delayed type depending on
  407.          *      the same type.
  408.          */
  409.         N_KIND(node) = as_obj_decl;
  410.         emap_put(first_obj_name , (char *) TRUE);
  411. #ifdef TBSN
  412.         emap_defined = emap_get(type_name); 
  413.         etup = EMAP_VALUE;
  414.         if (!emap_defined || tup_size(etup) == 0) {
  415.             ntup = tup_new1((char *) copy_node(node));
  416.         }
  417.         else {
  418.             ntup = tup_new(tup_size(etup)+1);
  419.             ntup[1] = (char *)copy_node(node);
  420.             for (tupi = 1; tupi <= tup_size(etup); tupi++) {
  421.                 ntup[tupi+1] = etup[tupi];
  422.             }
  423.         }
  424.         emap_put(type_name, (char *) ntup);
  425.         delete_node(node);
  426. #endif
  427.     }
  428.     else if (!is_var_decl && emap_get(first_obj_name)) {
  429.         /* 
  430.          * Full declaration of a deferred constant, 
  431.          * transform into assignment.
  432.          */
  433.         if (is_simple_type(type_name)) {
  434.             make_assign_node(node, first_obj_node, init_node);
  435.             expand(node);
  436.             N_SIDE(node) = N_SIDE(init_node);
  437.         }
  438.         else {
  439.             if (init_node == OPT_NODE) {
  440.                 /* record type */
  441.                 N_SIDE(node) = FALSE;
  442.             }
  443.             else {
  444.                 N_AST3(node) = OPT_NODE;
  445.                 expand(init_node);
  446.                 N_SIDE(node) = N_SIDE(init_node);
  447.                 make_insert_node(node, tup_new1((char *)copy_node(node)),
  448.                   new_assign_node(first_obj_node, init_node));
  449.             }
  450.         }
  451.         return;
  452.     }
  453.  
  454.     /*
  455.      * Normal declaration.
  456.      * Remark: following tests are always FALSE for constants
  457.      */
  458.     if (is_task_type(type_name)) {
  459.         /* Initial value for task objects is create_task */
  460.         init_node   = (Node) new_create_task_node(type_name);
  461.         N_AST1(node) = id_list_node;
  462.         N_AST2(node) = type_indic_node;
  463.         N_AST3(node) = init_node;
  464.     }
  465.     else if (is_access_type(type_name) && init_node == OPT_NODE) {
  466.         /* Initial value for (uninitialized) access objects is null*/
  467.         init_node   = (Node) new_null_node(type_name);
  468.         N_AST1(node) = id_list_node;
  469.         N_AST2(node) = type_indic_node;
  470.         N_AST3(node) = init_node;
  471.     }
  472.  
  473.     /* 
  474.      * Remark: type_name always constrained for variables 
  475.      */
  476.     if (is_array_type(type_name) && init_node != OPT_NODE) {
  477.         /* Try to propagate constraints statically */
  478.         if (!is_unconstrained(type_name) && is_unconstrained(init_type_name)) {
  479.             init_len  = array_nelem(init_node);
  480.             init_len_defined = array_nelem_defined;
  481.             const_len = array_nelem(type_indic_node);
  482.             const_len_defined = array_nelem_defined;
  483.             if (init_len_defined && const_len_defined) {
  484.                 if (init_len == const_len) {
  485.                     N_TYPE(init_node) = type_name;
  486.                 }
  487.                 else {
  488.                     make_raise_node(init_node, symbol_constraint_error);
  489.                     USER_WARNING("Mismatched length will raise",
  490.                       " CONSTRAINT_ERROR");
  491.                 }
  492.             }
  493.         }
  494.         else if (is_unconstrained(type_name) && 
  495.           !is_unconstrained(init_type_name)) {
  496.             N_UNQ(type_indic_node) = init_type_name;
  497.             FORTUP(id_node = (Node), N_LIST(id_list_node), ft1);
  498.                 TYPE_OF(N_UNQ(id_node)) = init_type_name;
  499.             ENDFORTUP(ft1);
  500.         }
  501.     }
  502.  
  503.     expand(type_indic_node);
  504.     N_SIDE(node) = N_SIDE(type_indic_node);
  505.     p = INIT_PROC((Symbol) base_type(type_name));
  506.     if (init_node == OPT_NODE  && p != (Symbol)0) {
  507.         init_node = build_init_call(first_obj_node, p, type_name, OPT_NODE);
  508.         expand(init_node);
  509.         N_AST1(node) = id_list_node;
  510.         N_AST2(node) = type_indic_node;
  511.         N_AST3(node) = init_node;
  512.         decl_node   = node;
  513.     }
  514.     else if (init_node != OPT_NODE ) {
  515.         is_agg = is_aggregate(init_node); /* may become an insert */
  516.         expand(init_node);
  517.         init_type_name = N_TYPE(init_node);
  518.         if (is_agg) {
  519.             replace_name(init_node, N_UNQ(init_node), first_obj_name);
  520.         }
  521.         if (is_agg && is_record_type(type_name) && is_unconstrained(type_name)){
  522.             if (N_KIND(node) == as_obj_decl) {
  523.                 /* Correct bit constrained in aggregate if unconstrained var */
  524.                 if (N_KIND(init_node) == as_insert ) {
  525.                     tup = N_LIST(N_AST1(N_AST1(N_AST1(init_node))));
  526.                 }
  527.                 else if ( N_KIND(init_node) == as_record_ivalue
  528.                   || N_KIND(init_node) == as_record_aggregate) {
  529.                     tup = N_LIST(N_AST1(N_AST1(init_node)));
  530.                 }
  531.                 else
  532.                     chaos("not so impossible expand2 problem");
  533.                 constrained_node = (Node) tup[1];
  534.                 const_val_node = N_AST2(constrained_node);
  535.                 N_VAL(const_val_node) = (char *) int_const(FALSE);
  536.             }
  537.             else if (NATURE(type_name) == na_record
  538.               && N_KIND(node) == as_const_decl) {
  539.                 /* Propagate type of aggregate to constant */
  540.                 TYPE_OF(first_obj_name) = init_type_name;
  541.                 N_UNQ(type_indic_node) = init_type_name;
  542.             }
  543.         }
  544.         /* Propagate possible pre-statements in front of this node*/
  545.         if (N_KIND(init_node) == as_insert) {
  546.             propagate_insert(init_node, node);
  547.             decl_node = N_AST1(node);
  548.         }
  549.         else {
  550.             decl_node = node;
  551.         }
  552.         N_SIDE(node) |= N_SIDE(init_node);
  553.         if (is_array_type(type_name)
  554.           && is_unconstrained(type_name) && !is_unconstrained(init_type_name)) {
  555.             /*
  556.              * Lucky! expand of init_node has been able to determine
  557.              * the constraints...
  558.              */
  559.             N_UNQ(type_indic_node) = init_type_name;
  560.             FORTUP(id_node  = (Node), N_LIST(id_list_node), ft1);
  561.                 TYPE_OF(N_UNQ(id_node)) = init_type_name;
  562.             ENDFORTUP(ft1);
  563.         }
  564.     }
  565.     else {
  566.         decl_node = node;
  567.     }
  568.  
  569.     /* If side-effect, replace by a list of single object decl.*/
  570.     if (N_SIDE(decl_node))
  571.         make_single_decl_list(node, decl_node);
  572. }
  573.  
  574. void expand_type(Node node)                                    /*;expand_type*/
  575. {
  576.     Fortup   ft1;
  577.     Node     id_node, small_node, proc_init_node, invariant_node,
  578.       variant_node, comp_node, delayed_node;
  579.     Node     cases_node, case_node;
  580.     Symbol   type_name, parent_type, comp_name, dummy;
  581.     Tuple    sig, tup, discr_list;
  582.     int      nat;
  583.  
  584.     /* Generate complete declaration if simple derivation is not enough*/
  585.     id_node   = N_AST1(node);
  586.     type_name    = N_UNQ(id_node);
  587.  
  588.     N_SIDE(node) = FALSE;
  589.     CONTAINS_TASK(type_name) = FALSE;
  590.  
  591.     if (TYPE_OF(type_name) == symbol_incomplete) {
  592.         /* case of an incomplete type in the private part of a package,
  593.          * whose  complete type declaration has appeared in the body,
  594.          * and saved in a dummy symbol. Retrieve, and update the entry
  595.          * for the type.
  596.          */
  597.         dummy = N_TYPE(node);
  598.         NATURE(type_name)    = NATURE(dummy);
  599.         TYPE_OF(type_name)   = TYPE_OF(dummy);
  600.         SIGNATURE(type_name) = SIGNATURE(dummy);
  601.         OVERLOADS(type_name) = OVERLOADS(dummy);
  602.         root_type(type_name) = root_type(dummy);
  603.     }
  604.     parent_type  = TYPE_OF(type_name);
  605.     nat = NATURE(type_name);
  606.     if (nat == na_type) {
  607.         /* Derived or predefined type*/
  608.         if (is_fixed_type(type_name)) {
  609.             /* Provide small if no representation clause*/
  610.             sig = SIGNATURE(type_name);
  611.             small_node = (Node) sig[5];
  612.             if (small_node == OPT_NODE) {
  613.                 /* Processing formerly done here now down by new_fixed_type()
  614.                  * in adasem, so it is an error to reach here.
  615.                  */
  616.                 chaos("fixed with small OPT_NODE");
  617.             }
  618.             CONTAINS_TASK(type_name) = (char *) FALSE;
  619.         }
  620.         else if (CONTAINS_TASK(parent_type)  /* derived access on task*/
  621.           && is_access_type(parent_type)) { /* needs own template*/
  622.             NATURE(type_name)        = na_access;
  623.             SIGNATURE(type_name)     = SIGNATURE(parent_type);
  624.             CONTAINS_TASK(type_name) = (char *) TRUE;
  625.         }
  626.         else {
  627.             CONTAINS_TASK(type_name) = CONTAINS_TASK(parent_type);
  628.             SIGNATURE(type_name)     = SIGNATURE(parent_type);
  629.             INIT_PROC(type_name)     = INIT_PROC(parent_type);
  630.         }
  631.     }
  632.     else if (nat == na_array) {
  633.         comp_name                = (Symbol) ((Tuple) SIGNATURE(type_name))[2];
  634.         CONTAINS_TASK(type_name) = CONTAINS_TASK(comp_name);
  635.         proc_init_node           = build_proc_init_ara(type_name);
  636.         if (proc_init_node != OPT_NODE) {
  637.             expand(proc_init_node);
  638.             make_insert_node(node, tup_new1((char *) copy_node(node)),
  639.               proc_init_node);
  640.         }
  641.     }
  642.     else if (nat == na_record) {
  643.         /* review following code: only altering 2nd part of SIGNATURE */
  644.         sig = SIGNATURE(type_name);
  645.         discr_list = (Tuple) sig[3];
  646.         invariant_node = (Node) sig[1];
  647.         variant_node = (Node) sig[2];
  648.  
  649.         FORTUP(comp_node= (Node), N_LIST(invariant_node), ft1);
  650.             expand(comp_node);
  651.             N_SIDE(node) |= N_SIDE(comp_node);
  652.         ENDFORTUP(ft1);
  653.         /* In case of a variant part of the type:
  654.          *      case disc is
  655.          *        when a..b => null;
  656.          *      end case;
  657.          * the record type is said to have no variant part.
  658.          */
  659.         if (variant_node != OPT_NODE)  {
  660.             cases_node = N_AST2(variant_node);
  661.             tup = tup_copy(N_LIST(cases_node));
  662.             case_node = (Node) tup_fromb(tup);
  663.             comp_node = N_AST2(case_node);
  664.             if (tup_size(tup) == 0 
  665.               && N_AST1(comp_node) == OPT_NODE
  666.               && N_AST2(comp_node) == OPT_NODE)  {
  667.                 variant_node = OPT_NODE;
  668.                 SIGNATURE(type_name)[2] = (char *) variant_node;
  669.             }
  670.         }
  671.         expand(variant_node);
  672.  
  673.         REC_WITH_TASKS  = FALSE;     /* just an assumption */
  674.         proc_init_node  = build_proc_init_rec(type_name);
  675.         CONTAINS_TASK(type_name) = (char *) REC_WITH_TASKS;
  676.         if (proc_init_node != OPT_NODE) {
  677.             expand(proc_init_node);
  678.             make_insert_node(node, tup_new1((char *) copy_node(node)),
  679.               proc_init_node);
  680.         }
  681.     }
  682.     else if (nat == na_subtype) {
  683.         N_AST3(node) = (Node)0;
  684.         N_KIND(node) = as_subtype_decl;
  685.         expand(node);
  686.     }
  687.     else if (nat == na_task_type) {
  688.         parent_type              = TYPE_OF(type_name);
  689.         SIGNATURE(type_name)     = SIGNATURE(parent_type);
  690.         CONTAINS_TASK(type_name) = (char *) TRUE;
  691.     }
  692.  
  693.     if (emap_get(type_name)) {
  694.         delayed_node = node_new(as_declarations);
  695.         if (emap_get(type_name))
  696.             N_LIST(delayed_node) = EMAP_VALUE;
  697.         expand(delayed_node);
  698.         N_SIDE(node) |= N_SIDE(delayed_node);
  699.         make_insert_node(node, tup_new1((char *)copy_node(node)), delayed_node);
  700.         emap_undef(type_name);
  701.     }
  702. }
  703.  
  704. void expand_subtype(Node node)                                /*;expand_subtype*/
  705. {
  706.     Node   id_node, lbd_node, ubd_node, de_node, delayed_node;
  707.     Symbol type_name, parent_type;
  708.     Tuple  field_list, constraint;
  709.     int    co_kind, i;
  710.  
  711.     id_node   = N_AST1(node);
  712.     type_name   = N_UNQ(id_node);
  713.     parent_type = TYPE_OF(type_name);
  714.  
  715.     constraint = (Tuple) get_constraint(type_name);
  716.     co_kind = (int) constraint[1];
  717.     if (co_kind == co_access) {
  718.         N_SIDE(node) = FALSE;
  719.     }
  720.     else if (co_kind == co_range) {
  721.         lbd_node = (Node) constraint[2];
  722.         ubd_node = (Node) constraint[3];
  723.         expand(lbd_node);
  724.         expand(ubd_node);
  725.         N_SIDE(node) = N_SIDE(lbd_node) | N_SIDE(ubd_node);
  726.     }
  727.     else if (co_kind == co_digits) {
  728.         lbd_node = (Node) constraint[2];
  729.         ubd_node= (Node) constraint[3];
  730.         expand(lbd_node);
  731.         expand(ubd_node);
  732.         N_SIDE(node) = N_SIDE(lbd_node) | N_SIDE(ubd_node);
  733.     }
  734.     else if (co_kind == co_delta) {
  735.         lbd_node = (Node) constraint[2];
  736.         ubd_node = (Node) constraint[3];
  737.         expand(lbd_node);
  738.         expand(ubd_node);
  739.         N_SIDE(node) = N_SIDE(lbd_node) | N_SIDE(ubd_node);
  740.     }
  741.     else if (co_kind == co_discr) {
  742.         field_list = (Tuple) constraint[2];
  743.         N_SIDE(node) = FALSE;
  744.         /* In C, field_list is tuple with successive domain symbol
  745.          * and range node values.
  746.          */
  747.         for (i = 1; i <= tup_size(field_list); i += 2) {
  748.             de_node = (Node) field_list[i+1];
  749.             expand(de_node);
  750.             N_SIDE(node) |= N_SIDE(de_node);
  751.         }
  752.     }
  753.     else if (co_kind == co_index) {
  754.         N_SIDE(node) = FALSE;
  755.     }
  756.     else
  757.         compiler_error_c("Unknown constraint in subtype decl: ", constraint);
  758.  
  759.     /*       Transmit tasks_declared: */
  760.     CONTAINS_TASK(type_name) = CONTAINS_TASK(parent_type);
  761.  
  762.     if (emap_get(type_name)) {
  763.         delayed_node         = node_new(as_declarations);
  764.         N_LIST(delayed_node) = EMAP_VALUE;
  765.         expand(delayed_node);
  766.         N_SIDE(node) |= N_SIDE(delayed_node);
  767.         make_insert_node(node, tup_new1((char *)copy_node(node)), delayed_node);
  768.         emap_undef(type_name);
  769.     }
  770. }
  771.  
  772. void expand_attr(Node node)                                    /*;expand_attr*/
  773. {
  774.     Node   precision, arg1, arg2, low_node, high_node;
  775.     Symbol type_name, index_name, obj_name;
  776.     Tuple  index_t, tup;
  777.     Rational    delta, fx_low, fx_high, fx_ma;
  778.     int    attr, dim, discr_dep, result, i;
  779.     int    *rat_n, *rat_d; /* Multi-precision integers */
  780.  
  781.     Const   low_const, high_const;
  782.  
  783.     arg1 = N_AST2(node);
  784.     arg2 = N_AST3(node);
  785.     attr = (int) attribute_kind(node);
  786.  
  787.     /* BASE attribute is evaluated to a type mark.  */
  788.     if (attr == ATTR_BASE) {
  789.         make_name_node(node, base_type(N_UNQ(arg2)));
  790.     }
  791.     else {
  792.         expand(arg1);
  793.     }
  794.  
  795.     if ((arg2 != (Node)0 ? arg2: OPT_NODE) != OPT_NODE)
  796.         expand(arg2);
  797.  
  798.     /* Transformations on attributes */
  799.     switch (attr) {
  800.     case(ATTR_O_RANGE):
  801.     case(ATTR_O_FIRST):
  802.     case(ATTR_O_LAST):
  803.     case(ATTR_O_LENGTH):
  804.  
  805.         /* if the first parameter is a simple name, if its type is
  806.          * constrained and, if it is an array, its bounds must no depend on
  807.          * discriminant, then we can make a
  808.          * conversion to an attribute to its type. This will be very useful
  809.          * since the expansion of the T_attribute may produce some constant
  810.          */
  811.  
  812.         discr_dep = FALSE;
  813.         type_name = get_type(arg1);
  814.         if (is_array_type(type_name)) {
  815.             index_t = index_types(type_name);
  816.             dim = get_ivalue_int(arg2);
  817.             index_name   = (Symbol) index_t[dim];
  818.             tup = SIGNATURE(index_name);
  819.             low_node = (Node) tup[2];
  820.             high_node = (Node) tup[3];
  821.             discr_dep = is_discr_ref(low_node) || is_discr_ref(high_node);
  822.         }
  823.         if (is_simple_name (arg1) && !is_unconstrained (get_type(arg1))
  824.           && !discr_dep) {
  825.             N_AST2 (node) = new_name_node (get_type (arg1));
  826.             /* convert from O_ to T_ attribute by adding one */
  827.             attribute_kind(node) = (char *) ((int)attribute_kind(node) + 1);
  828.             expand (node); 
  829.         }
  830.  
  831. #ifdef TBSL
  832.  
  833.     /* In case of an aggregate, the object itself declares its type and this
  834.     * transformation leads to a RELAY_SET problem. 
  835.     */
  836.  
  837.         /* Transform into T_xxx of type if possible */
  838.         type_name = get_type(arg1);
  839.         if (is_array_type(type_name)) {
  840.             index_t = index_types(type_name);
  841.             dim = get_ivalue_int(arg2);
  842.             index_name   = (Symbol) index_t[dim];
  843.             tup = SIGNATURE(index_name);
  844.             low_node = (Node) tup[2];
  845.             high_node = (Node) tup[3];
  846.             discr_dep = is_discr_ref(low_node) || is_discr_ref(high_node);
  847.         }
  848.         else {
  849.             discr_dep = FALSE;
  850.         }
  851.         if (! (discr_dep || is_unconstrained(type_name))) {
  852.             N_KIND(arg1) = as_simple_name;
  853.             N_AST1(arg1) = (Node)0;
  854.             N_AST2(arg1) = (Node)0;
  855.             N_AST3(arg1) = (Node)0;
  856.             N_AST3(arg1) = (Node)0;
  857.             N_UNQ(arg1)  = type_name;
  858.             N_TYPE(arg1) = type_name;
  859.             /* convert from O_ to T_ attribute by adding one */
  860.             attribute_kind(node) = (char *) ((int)attribute_kind(node) + 1);
  861.             expand(node);
  862.         }
  863. #endif
  864.         break;
  865.     case(ATTR_T_FIRST):
  866.         type_name = N_UNQ(arg1);
  867.         if (is_array_type(type_name)) {
  868.             index_t = index_types(type_name);
  869.             dim = get_ivalue_int(arg2);
  870.             type_name = (Symbol) index_t[dim];
  871.         }
  872.         tup = SIGNATURE(type_name);
  873.         low_node = (Node) tup[2];
  874.         if (is_ivalue(low_node)) {
  875.             copy_attributes(low_node, node);
  876.         }
  877.         break;
  878.  
  879.     case(ATTR_T_LAST):
  880.         type_name = N_UNQ(arg1);
  881.         if (is_array_type(type_name)) {
  882.             index_t = index_types(type_name);
  883.             dim = get_ivalue_int(arg2);
  884.             type_name = (Symbol) index_t[dim];
  885.         }
  886.         tup = SIGNATURE(type_name);
  887.         high_node = (Node) tup[3];
  888.         if (is_ivalue(high_node)) {
  889.             copy_attributes(high_node, node);
  890.         }
  891.         break;
  892.  
  893.     case(ATTR_O_CONSTRAINED):
  894.         for (;;) {
  895.             if (N_KIND(arg1) == as_index || N_KIND(arg1) == as_selector) {
  896.                 break;
  897.                 /* constant_folding TBSL */
  898.             }
  899.             else if (N_KIND(arg1) == as_all) {
  900.                 /* Allocated objects always constrained */
  901.                 make_ivalue_node(node, int_const(TRUE), symbol_boolean);
  902.                 break;
  903.             }
  904.             else if (N_KIND(arg1) == as_simple_name) {
  905.                 obj_name = N_UNQ(arg1);
  906.                 if (NATURE(obj_name) == na_constant
  907.                   || NATURE(obj_name) == na_in
  908.                   || ! is_unconstrained(TYPE_OF(obj_name))) {
  909.                     make_ivalue_node(node, int_const(TRUE), symbol_boolean);
  910.                 }
  911.                 break;
  912.             }
  913.             else {
  914.                 compiler_error("Illegal prefix for attribute");
  915.             }
  916.         }
  917.         break;
  918.  
  919.     case(ATTR_POS):
  920.         /* Transform into convert */
  921.         /* Since N_AST3 and N_UNQ overlaid, clear N_AST3 field if 
  922.          * currently defined.
  923.          */
  924.         if (N_AST3_DEFINED(N_KIND(node))) {
  925.             N_AST3(node) = (Node)0;
  926.         }
  927.         N_KIND(node) = as_convert;
  928.         N_AST1(node) = arg1;
  929.         N_AST2(node) = arg2;
  930.         break;
  931.  
  932.     case(ATTR_COUNT):
  933.         /*This attribute is only allowed within the body of T (9.9(5)) */
  934.         N_AST1(arg1) = OPT_NODE;
  935.         break;
  936.  
  937.     case(ATTR_O_SIZE):
  938.         /* apply it to type of prefix. */
  939.         /* type_name = get_type(arg1);
  940.            * make_name_node(arg1, type_name);
  941.           * attribute_kind(node) = (char *) ATTR_T_SIZE;
  942.          */
  943.         break;
  944.  
  945.     case(ATTR_WIDTH):
  946.  
  947.         type_name = N_UNQ(arg1);
  948.         if (is_static_type(type_name)) {
  949.             int low_int, high_int, ivalue_int;
  950.             tup = SIGNATURE(type_name);
  951.             low_node = (Node) tup[2];
  952.             high_node = (Node) tup[3];
  953.             low_const = get_ivalue (low_node);
  954.             high_const = get_ivalue (high_node);
  955.  
  956.             /* this following test has been added because the bounds of the
  957.              * range may be not static. In the previous version there was an
  958.              * error during the get_ivalue_int.  Some optimizations can still
  959.              * be performed since we just generate the WIDTH attribute
  960.              */
  961.  
  962.             if (low_const->const_kind != CONST_OM
  963.               && high_const->const_kind != CONST_OM) {
  964.                 low_int   = get_ivalue_int(low_node);
  965.                 high_int  = get_ivalue_int(high_node);
  966.                 if (is_integer_type(type_name)) {
  967.                     if (low_int > high_int)
  968.                         result = 0;
  969.                     else {
  970.                         char *val_str = emalloct(10, "expand-attr-wid-1");
  971.                         low_int =  abs (low_int);
  972.                         high_int = abs (high_int);
  973.                         ivalue_int = (low_int > high_int ? low_int : high_int);
  974.                         sprintf(val_str, " %d", ivalue_int);
  975.                         ivalue_int = strlen(val_str);
  976.                         efreet(val_str, "expand-attr-wid-2");
  977.                         result = ivalue_int;
  978.                     }
  979.                 }
  980.                 else {     /* Enumeration types */
  981.                     int len, v;
  982.                     tup = (Tuple) literal_map(root_type(type_name));
  983.                     ivalue_int = 0;
  984.                     for (i = 1; i <= tup_size(tup); i += 2) {
  985.                         len = strlen(tup[i]);
  986.                         v = (int) tup[i+1];
  987.                         if (len > ivalue_int && (v >= low_int && v  <=high_int))
  988.                             ivalue_int = len;
  989.                     }
  990.                     result = ivalue_int;
  991.                 }
  992.                 make_ivalue_node(node, int_const(result), symbol_integer);
  993.             } 
  994.         }
  995.         break;
  996.  
  997.     /* The minimum number of characters needed for the integer
  998.      *  part of the decimal representation (including sign).
  999.      */
  1000.     case(ATTR_FORE):
  1001.         tup = SIGNATURE(N_UNQ(arg1));
  1002.         low_node = (Node) tup[2];
  1003.         high_node = (Node) tup[3];
  1004.         if (is_ivalue(low_node) && is_ivalue(high_node)) {
  1005.             fx_low = RATV((Const)N_VAL(low_node));
  1006.             fx_high = RATV((Const) N_VAL(high_node));
  1007.             if (rat_geq(rat_abs(fx_high), rat_abs(fx_low)))
  1008.                 fx_ma = rat_abs(fx_high);
  1009.             else 
  1010.                 fx_ma = rat_abs(fx_low);
  1011.             rat_n = num(fx_ma);
  1012.             rat_d = den(fx_ma);
  1013.             result = 2;
  1014.             while (int_geq(int_quo(rat_n , rat_d) , ivalue_10)) {
  1015.                 rat_d = int_mul(rat_d, ivalue_10);
  1016.                 result += 1;
  1017.             }
  1018.             make_ivalue_node(node, int_const(result), symbol_integer);
  1019.         }
  1020.         break;
  1021.  
  1022.     /*      The number of decimal digits needed after the decimal point
  1023.      *        = smallest n such that (10**N)*FX'DELTA >= 1.0
  1024.      */
  1025.     case(ATTR_AFT):
  1026.         tup = SIGNATURE(N_UNQ(arg1));
  1027.         low_node = (Node) tup[2];
  1028.         high_node = (Node) tup[3];
  1029.         precision = (Node) tup[4];
  1030.         delta = RATV((Const) N_VAL(precision));
  1031.         fx_low = RATV((Const)N_VAL(low_node));
  1032.         fx_high = RATV((Const) N_VAL(high_node));
  1033.         result = 1;
  1034.         while (rat_lss(delta, rat_fri(int_fri(1), int_fri(10)) )){
  1035.             delta = rat_mul(delta, rat_fri(int_fri(10), int_fri(1)));
  1036.             result += 1;
  1037.         }
  1038.         make_ivalue_node(node, int_const(result), symbol_integer);
  1039.         break;
  1040.  
  1041.     case(ATTR_SAFE_LARGE):
  1042.         /* Equal to 'large of base type. */
  1043.         N_UNQ(arg1) = base_type(N_UNQ(arg1));
  1044.         attribute_kind(node) = (char *)ATTR_LARGE;
  1045.         break;
  1046.  
  1047.     case(ATTR_SAFE_SMALL):
  1048.         /* Equal to 'small of base type. */
  1049.         N_UNQ(arg1) = base_type(N_UNQ(arg1));
  1050.         attribute_kind(node) = (char *)ATTR_SMALL;
  1051.         break;
  1052.     }
  1053.  
  1054.     N_SIDE(node) = FALSE;
  1055. }
  1056.  
  1057. void expand_string(Node node)                                /*;expand_string*/
  1058. {
  1059.     Node   lbd_node, ubd_node, check_node, range_lbd_node, range_ubd_node,
  1060.       base_lbd_node;
  1061.     Symbol str_type, comp_type, new_type, indx_type, base_index_type;
  1062.     Tuple  ntup, stmts_list, tup, decls;
  1063.     int    str_len, lowest_char, highest_char, n, ubd_val_int, lbd, ubd, i;
  1064.     Const  hg_val, lw_val;
  1065.  
  1066.     str_type = N_TYPE(node);
  1067.     str_len  = tup_size((Tuple) N_VAL(node));
  1068.     if (str_len != 0) {
  1069.         /* SETL has lowest_char=MAX/...highest_char = MIN ... !! - we fix this*/
  1070.         ntup = (Tuple) N_VAL(node);
  1071.         lowest_char = (int) ntup[1];
  1072.         highest_char = (int) ntup[1];
  1073.         n = tup_size(ntup);
  1074.         for (i = 2; i <= n; i++) {
  1075.             if ((int)ntup[i] < lowest_char) lowest_char = (int) ntup[i];
  1076.             if ((int)ntup[i] > highest_char) highest_char = (int) ntup[i];
  1077.         }
  1078.         /*lowest_char  = max/N_VAL(node); !!*/
  1079.         /*highest_char = min/N_VAL(node); !!*/
  1080.         comp_type    = (Symbol) component_type(str_type);
  1081.         stmts_list   = tup_new(0);
  1082.         tup = SIGNATURE(comp_type);
  1083.         lbd_node = (Node) tup[2];
  1084.         ubd_node = (Node) tup[3];
  1085.  
  1086.         lw_val = get_ivalue(lbd_node);
  1087.         if (lw_val->const_kind != CONST_OM) {
  1088.             if (lowest_char <  get_ivalue_int(lbd_node)) {
  1089.                 make_raise_node(node, symbol_constraint_error);
  1090.                 USER_WARNING("Character in string will raise ",
  1091.                   " CONSTRAINT_ERROR");
  1092.             }
  1093.         }
  1094.         else {
  1095.             check_node        = node_new(as_discard);
  1096.             N_AST1(check_node) = new_qual_range_node( new_ivalue_node(
  1097.               int_const(lowest_char), symbol_character), comp_type);
  1098.             N_TYPE(check_node) = comp_type;
  1099.             N_SIDE(check_node) = FALSE;
  1100.             stmts_list = tup_new1((char *) check_node);
  1101.         }
  1102.         hg_val = get_ivalue(ubd_node);
  1103.         if (hg_val->const_kind != CONST_OM) {
  1104.             if (highest_char >  get_ivalue_int(ubd_node)) {
  1105.                 make_raise_node(node, symbol_constraint_error);
  1106.                 USER_WARNING("Character in string will raise ",
  1107.                   "CONSTRAINT_ERROR");
  1108.             }
  1109.         }
  1110.         else {
  1111.             check_node        = node_new(as_discard);
  1112.             N_AST1(check_node) = new_qual_range_node( new_ivalue_node(
  1113.               int_const(highest_char), symbol_character), comp_type);
  1114.             N_TYPE(check_node) = comp_type;
  1115.             N_SIDE(check_node) = FALSE;
  1116.             stmts_list = tup_with(stmts_list, (char *) check_node);
  1117.         }
  1118.         if (tup_size(stmts_list) != 0) {
  1119.             make_insert_node(node, stmts_list, copy_node(node));
  1120.             node       = N_AST1(node);
  1121.             N_SIDE(node) = FALSE;
  1122.         }
  1123.     }
  1124.  
  1125.     /* construct subtype */
  1126.  
  1127.     tup = index_types(str_type);
  1128.     indx_type = (Symbol) tup[1];
  1129.     tup = SIGNATURE(indx_type);
  1130.     lbd_node = (Node) tup[2];
  1131.     ubd_node = (Node) tup[3];
  1132.     if (is_ivalue(lbd_node)) {
  1133.         lbd = get_ivalue_int(lbd_node);
  1134.         base_index_type = base_type(indx_type);
  1135.         tup = SIGNATURE(base_index_type);
  1136.         base_lbd_node = (Node) tup[2];
  1137.         if (str_len == 0
  1138.           && const_eq(get_ivalue(lbd_node), get_ivalue(base_lbd_node))) {
  1139.             /* LRM 4.2(3) */
  1140.             make_raise_node(node, symbol_constraint_error);
  1141.             USER_WARNING("Null string will raise CONSTRAINT_ERROR",
  1142.               " (LRM 4.2(3))" );
  1143.         }
  1144.         else {
  1145.             ubd_val_int    = lbd + str_len - 1;
  1146.             if (is_ivalue(ubd_node)) {
  1147.                 ubd = get_ivalue_int(ubd_node);
  1148.                 if (!is_unconstrained(str_type)) {
  1149.                     if ((str_len != 0 && ubd_val_int != ubd)
  1150.                       || (str_len == 0 && ubd >= lbd)) {
  1151.                         make_raise_node(node, symbol_constraint_error);
  1152.                         USER_WARNING("String literal will raise ",
  1153.                           "CONSTRAINT_ERROR");
  1154.                     }
  1155.                     else return;    /* static bounds ok. */
  1156.                 }
  1157.                 else {    /* unconstrained context. Length may be too big. */
  1158.                     if (ubd_val_int > ubd) {
  1159.                         make_raise_node(node, symbol_constraint_error);
  1160.                         USER_WARNING("String literal will raise ",
  1161.                           "CONSTRAINT_ERROR");
  1162.                     }
  1163.                 }
  1164.             }
  1165.             /* else gen_subtype will emit a qual sub */
  1166.         }
  1167.         range_lbd_node = copy_node(lbd_node);
  1168.         range_ubd_node = new_ivalue_node(int_const(ubd_val_int),
  1169.           N_TYPE(range_lbd_node));
  1170.     }
  1171.     else { /* lbd_node is not an ivalue */
  1172.         /* write range_lbd_node  as an attribute node */
  1173.         range_lbd_node = new_attribute_node(ATTR_T_FIRST,
  1174.           new_name_node(indx_type), OPT_NODE, indx_type);
  1175.         range_ubd_node = new_binop_node(symbol_addi, range_lbd_node,
  1176.           new_ivalue_node(int_const(str_len-1), base_type(indx_type)),
  1177.           base_type(indx_type));
  1178.         /* gen_subtype will emit a qual sub on the index type */
  1179.     }
  1180.  
  1181.     if (N_KIND(node) != as_raise) {
  1182.         tup = constrained_type(str_type, range_lbd_node, range_ubd_node);
  1183.         new_type = (Symbol) tup[1];
  1184.         decls = (Tuple) tup[2];
  1185.         N_TYPE(node) = new_type;
  1186.         N_SIDE(node) = FALSE;
  1187.         make_insert_node(node, decls, copy_node(node));
  1188.     }
  1189.     N_SIDE(node) = FALSE;
  1190. }
  1191.  
  1192. void expand_op(Node node)                                        /*;expand_op*/
  1193. {
  1194.     Node   op_node, args_node, arg1, arg2, conv_node, to_type_node, type_node,
  1195.       lbd_node, ubd_node, constraint_node, lbd_node1, ubd_node1;
  1196.     Symbol op_name, range_name, type_name;
  1197.     Symbol indx_t, str1_type;
  1198.     Tuple  tup, constraint;
  1199.     Node   comp;
  1200.  
  1201.     op_node = N_AST1(node);
  1202.     args_node = N_AST2(node);
  1203.     op_name = N_UNQ(op_node);
  1204.     arg1 = (Node) ((Tuple)N_LIST(args_node) [1]);
  1205.     arg2 = (Node) ((Tuple)N_LIST(args_node) [2]);
  1206.  
  1207.     /* Constant folding: concatenation of two non-null string which index_type
  1208.      * is static.
  1209.      */
  1210.     if (op_name == symbol_cat && N_KIND(arg1) == as_string_ivalue
  1211.       && N_KIND(arg2) == as_string_ivalue ) {
  1212.         str1_type = N_TYPE(arg1);
  1213.         indx_t = (Symbol) index_types(str1_type)[1];
  1214.         tup = SIGNATURE(indx_t);
  1215.         lbd_node1 = (Node) tup[2];
  1216.         ubd_node1 = (Node) tup[3];
  1217.         /* if the index_type is static and the length of both the strings
  1218.          * is not null, then we transform the node into a string_ivalue
  1219.          * which is the concatenation of the two strings.
  1220.          */
  1221.         if (N_KIND(lbd_node1) == as_ivalue && N_KIND(ubd_node1) == as_ivalue
  1222.           && tup_size((Tuple) N_VAL(arg1)) &&tup_size((Tuple) N_VAL(arg2))) {
  1223.             N_KIND(node) = as_string_ivalue;
  1224.             N_AST1(node) = N_AST2(node) = N_AST3(node) = N_AST4(node) = (Node)0;
  1225.             N_VAL(node) = (char *) tup_add((Tuple)N_VAL(arg1),
  1226.               (Tuple)N_VAL(arg2));
  1227.             N_TYPE(node) = str1_type;
  1228.             expand(node);    /* and generate subtype, etc. */
  1229.         }
  1230.     }
  1231.  
  1232.     /* case of the new catenation instructions */
  1233.  
  1234.     else if  (op_name == symbol_cat_ca) {
  1235.         comp = copy_node (arg1);
  1236.         N_KIND (arg1) = as_row;
  1237.         N_AST1 (arg1) = comp;
  1238.         N_AST2 (arg1) = (Node) 0;
  1239.         N_TYPE (arg1) = N_TYPE (node);
  1240.         N_UNQ (N_AST1(node)) = symbol_cat;
  1241.     }
  1242.     else if  (op_name == symbol_cat_ac) {
  1243.         comp = copy_node (arg2);
  1244.         N_KIND (arg2) = as_row;
  1245.         N_AST1 (arg2) = comp;
  1246.         N_AST2 (arg2) = (Node) 0;
  1247.         N_TYPE (arg2) = N_TYPE (node);
  1248.         N_UNQ (N_AST1(node)) = symbol_cat;
  1249.     }
  1250.     else if  (op_name == symbol_cat_cc) {
  1251.         comp = copy_node (arg2);
  1252.         N_KIND (arg2) = as_row;
  1253.         N_AST1 (arg2) = comp;
  1254.         N_AST2 (arg2) = (Node) 0;
  1255.         N_TYPE (arg2) = N_TYPE (node);
  1256.  
  1257.         comp = copy_node (arg1);
  1258.         N_KIND (arg1) = as_row;
  1259.         N_AST1 (arg1) = comp;
  1260.         N_AST2 (arg1) = (Node) 0;
  1261.         N_TYPE (arg1) = N_TYPE (node);
  1262.  
  1263.         N_UNQ (N_AST1(node)) = symbol_cat;
  1264.     }
  1265.     /* Transform some operations: */
  1266.     else if (op_name == symbol_mulfli || op_name == symbol_divfli) {
  1267.         conv_node           = node_new(as_convert);
  1268.         to_type_node        = new_name_node(symbol_universal_real);
  1269.         N_AST1(conv_node)   = to_type_node;
  1270.         N_AST2(conv_node)   = arg2;
  1271.         N_TYPE(conv_node)   = symbol_universal_real;
  1272.         arg2                = conv_node;
  1273.         tup  = tup_new(2);
  1274.         tup[1] = (char *) arg1; 
  1275.         tup[2] = (char *) arg2;
  1276.         N_LIST(args_node)   = tup;
  1277.         N_UNQ(op_node) = (op_name == symbol_mulfli) ? symbol_mulfl 
  1278.           : symbol_divfl;
  1279.     }
  1280.     else if (op_name == symbol_mulifx) {
  1281.         tup = tup_new(2);
  1282.         tup[1] = (char *) arg2; 
  1283.         tup[2] = (char *) arg1;
  1284.         N_LIST(args_node)   = tup;
  1285.         N_UNQ(op_node)      = symbol_mulfxi;
  1286.     }
  1287.     else if (op_name == symbol_in || op_name == symbol_notin) {
  1288.         if (!is_simple_name(arg2)) {
  1289.             /* Add subtype declaration */
  1290.             range_name = new_unique_name("range");
  1291.             type_name  = N_TYPE(arg2);
  1292.             if (N_KIND(arg2) == as_attribute) {
  1293.                 lbd_node        = copy_node(arg2);
  1294.                 ubd_node        = copy_tree(arg2);
  1295.                 /*lbd_attr_node = N_AST1(lbd_node); -- not needed in C version*/
  1296.                 /*ubd_attr_node = N_AST1(ubd_node); -- not needed in C version*/
  1297.                 if ((int) attribute_kind(lbd_node) == ATTR_T_RANGE) {
  1298.                     attribute_kind(lbd_node) = (char *) ATTR_T_FIRST;
  1299.                     attribute_kind(ubd_node) = (char *)ATTR_T_LAST;
  1300.                 }
  1301.                 else {  /* 'O_RANGE' */
  1302.                     attribute_kind(lbd_node) = (char *) ATTR_O_FIRST;
  1303.                     attribute_kind(ubd_node) = (char *) ATTR_O_LAST;
  1304.                 }
  1305.                 constraint = constraint_new(co_range);
  1306.                 constraint[2] = (char *) lbd_node;
  1307.                 constraint[3] = (char *) ubd_node;
  1308.             }
  1309.             else { /* as_subtype */
  1310.                 Tuple t;
  1311.  
  1312.                 constraint_node      = N_AST2(arg2);
  1313.                 lbd_node = N_AST1(constraint_node);
  1314.                 ubd_node = N_AST2(constraint_node);
  1315.  
  1316.                 t = SIGNATURE(type_name);
  1317.                 constraint = constraint_new((int)numeric_constraint_kind(t));
  1318.                 numeric_constraint_low(constraint)  = (char *) lbd_node;
  1319.                 numeric_constraint_high(constraint) = (char *) ubd_node;
  1320.  
  1321.                 /* inherit precision of real subtype from parent type */
  1322.                 if (numeric_constraint_kind(t) == (char *)co_digits) {
  1323.                     numeric_constraint_digits(constraint) =
  1324.                       numeric_constraint_digits(t);
  1325.                 }
  1326.                 else if (numeric_constraint_kind(t) == (char *)co_delta) {
  1327.                     numeric_constraint_delta(constraint) =
  1328.                       numeric_constraint_delta(t);
  1329.                     numeric_constraint_small(constraint) =
  1330.                       numeric_constraint_small(t);
  1331.                 }
  1332.             }
  1333.             NATURE(range_name) = na_subtype;
  1334.             TYPE_OF(range_name) = base_type(type_name);
  1335.             SIGNATURE(range_name) = constraint;
  1336.             ALIAS(range_name) = ALIAS(type_name);
  1337.             type_node             = node_new(as_subtype_decl);
  1338.             N_AST1(type_node)      = new_name_node(range_name);
  1339.             make_insert_node(node,tup_new1((char *)type_node), copy_node(node));
  1340.             make_name_node(arg2, range_name);
  1341.         }
  1342.     }
  1343.  
  1344.     expand(arg1);
  1345.     expand(arg2);
  1346.     N_SIDE(node) = N_SIDE(arg1) | N_SIDE(arg2);
  1347. }
  1348.  
  1349. void expand_for(Node node)                                        /*;expand_for*/
  1350. {
  1351.     Node   id_node, range_node, low_node, high_node, ubd_node, lbd_node,
  1352.       arg1, arg2, type_node, new_range_node, decl_node;
  1353.     Symbol type_name, type_mark;
  1354.     Const  lbd, ubd, low_const, high_const;
  1355.     Tuple  tup;
  1356.     int    nk, attr_prefix;
  1357.  
  1358.     id_node = N_AST1(node);
  1359.     range_node = N_AST2(node);
  1360.     nk = N_KIND(range_node);
  1361.     if (nk == as_subtype){
  1362.         type_node = N_AST1(range_node);
  1363.         type_mark = N_UNQ(type_node);
  1364.         new_range_node    = N_AST2(range_node);
  1365.         low_node = N_AST1(new_range_node);
  1366.         high_node = N_AST2(new_range_node);
  1367.         type_name = new_unique_name("loop_type");
  1368.         tup = constraint_new(co_range);
  1369.         tup[2] = (char *) low_node;
  1370.         tup[3] = (char *) high_node;
  1371.         new_symbol(type_name, na_subtype, type_mark, tup, ALIAS(type_mark));
  1372.         if (not_included(type_name, type_mark) ) {
  1373.             decl_node = new_subtype_decl_node(type_name);
  1374.             expand(decl_node);
  1375.             make_insert_node(node,tup_new1((char *)decl_node), copy_node(node));
  1376.             node = N_AST1(node);
  1377.             type_node = new_name_node(type_name);
  1378.             low_node  = new_attribute_node(ATTR_T_FIRST, type_node, OPT_NODE,
  1379.               type_name);
  1380.             high_node = new_attribute_node(ATTR_T_LAST, type_node, OPT_NODE,
  1381.               type_name);
  1382.         }
  1383.         else {
  1384.             /* we don't need type_name*/
  1385.             new_symbol(type_name, na_void, (Symbol)0, (Tuple)0, (Symbol)0);
  1386.         }
  1387.     }
  1388.     else if (nk == as_range) {
  1389.         low_node = N_AST1(range_node);
  1390.         high_node = N_AST2(range_node);
  1391.     }
  1392.     else if (nk == as_name) {
  1393.         range_node = N_AST1(range_node);
  1394.         type_name = N_UNQ(range_node);
  1395.         tup  = get_constraint(type_name);
  1396.         low_node = (Node) tup[2];
  1397.         high_node = (Node) tup[3];
  1398.         if (!is_ivalue(low_node) || !is_ivalue(high_node)) {
  1399.             low_node = new_attribute_node(ATTR_T_FIRST,
  1400.               copy_node(range_node), OPT_NODE, type_name);
  1401.             high_node= new_attribute_node(ATTR_T_LAST,
  1402.               copy_node(range_node), OPT_NODE, type_name);
  1403.         }
  1404.     }
  1405.     else if (nk == as_simple_name) {
  1406.         type_name = N_UNQ(range_node);
  1407.         tup = get_constraint(type_name);
  1408.         low_node = (Node) tup[2];
  1409.         high_node = (Node) tup[3];
  1410.         if (!is_ivalue(low_node) || !is_ivalue(high_node)) {
  1411.             low_node = new_attribute_node(ATTR_T_FIRST,
  1412.               copy_node(range_node), OPT_NODE, type_name);
  1413.             high_node= new_attribute_node(ATTR_T_LAST,
  1414.               copy_node(range_node), OPT_NODE, type_name);
  1415.         }
  1416.     }
  1417.     else if (nk == as_attribute) {
  1418.         /*att_node = N_AST1(range_node);*/
  1419.         arg1 = N_AST2(range_node);
  1420.         arg2 = N_AST3(range_node);
  1421.         attr_prefix = (int)attribute_kind(range_node)-ATTR_RANGE;
  1422.         /* 'T' or 'O'*/
  1423.         attribute_kind(range_node) = (char *) ((int)attr_prefix + ATTR_FIRST);
  1424.         low_node = range_node;
  1425.         high_node = new_attribute_node(attr_prefix + ATTR_LAST,
  1426.           copy_node(arg1), copy_node(arg2), get_type(range_node));
  1427.     }
  1428.     else {
  1429.         compiler_error_k("Unexpected range in for: ", range_node );
  1430.         low_node = high_node = OPT_NODE;
  1431.     }
  1432.     expand(low_node);
  1433.     expand(high_node);
  1434.     low_const = get_ivalue(low_node);
  1435.     high_const = get_ivalue(high_node);
  1436.     tup = get_constraint(get_type(range_node));
  1437.     lbd_node = (Node) tup[2];
  1438.     ubd_node = (Node)tup[3];
  1439.     if (low_const->const_kind != CONST_OM
  1440.       && high_const->const_kind != CONST_OM
  1441.       && get_ivalue_int(high_node) < get_ivalue_int(low_node) ) {
  1442.         /* static null range */
  1443.         delete_node(node);
  1444.     }
  1445.     else {
  1446.         lbd = get_ivalue(lbd_node);
  1447.         ubd = get_ivalue(ubd_node);
  1448.         if (low_const->const_kind != CONST_OM
  1449.           && high_const->const_kind != CONST_OM
  1450.           && lbd->const_kind != CONST_OM
  1451.           && ubd->const_kind != CONST_OM
  1452.           && (get_ivalue_int(lbd_node) > get_ivalue_int(low_node)
  1453.           || get_ivalue_int(ubd_node) < get_ivalue_int(high_node))) {
  1454.             /* static violation of constraints */
  1455.             make_raise_node(node, symbol_constraint_error);
  1456.             USER_WARNING("Evaluation of range will raise",
  1457.               " CONSTRAINT_ERROR");
  1458.         }
  1459.         else {
  1460.             N_AST1(node) = id_node;
  1461.             N_AST2(node) = low_node;
  1462.             N_AST3(node) = high_node;
  1463.         }
  1464.     }
  1465. }
  1466.